home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist01.zoo / lsp / stepper.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1990-11-09  |  7.5 KB  |  233 lines
  1. ;
  2. ; File: NSTEP.LSP
  3. ; Author: Ray Comas (comas@math.lsa.umich.edu)
  4. ;
  5.  
  6. (defmacro while (test &rest forms) `(do () ((not ,test)) ,@forms))
  7. (setf newline #\newline)  ;define newline
  8. (setf *hooklevel* 0)    ;create the nesting level counter.
  9. (setf *cf* 2)        ;create the compression counter
  10. (setf *fcn* '*all*)    ;create "one-shot" breakpoint specifier
  11. (setf *steplist* nil)    ;create breakpoint list
  12. (setf *steptrace* '(T . T))
  13. (setf *callist* nil)    ;create call list for backtrace
  14.  
  15. ;this macro invokes the stepper.
  16. (defmacro step (form &aux val)
  17.      `(progn
  18.        (setf *hooklevel* 0)        ;init nesting counter
  19.        (setf *cf* 2)            ;init compression counter
  20.        (setf *fcn* '*all*)        ;init break-point specifier
  21.        (setf *callist* (list (car ',form)))  ;init call list
  22.        (setf *steptrace* '(T . T))
  23.  
  24.        (prin1 ',form)            ;print the form
  25.        (terpri)
  26.        (setf val (evalhook ',form        ;eval, and kick off stepper
  27.                            #'eval-hook-function
  28.                            nil
  29.                            nil))
  30.        (princ *hooklevel*)           ;print returned value
  31.        (princ " <==< ")
  32.        (prin1 val)
  33.        (terpri)
  34.        val))                         ;and return it
  35.  
  36. (defun eval-hook-function (form env &aux val cmd)
  37.      (setf *hooklevel* (1+ *hooklevel*))    ;incr. the nesting level
  38.      (cond ((consp form)            ;if interpreted function ...
  39.              (setf *callist*
  40.           (cons (car form) *callist*))  ;add fn. to call list
  41.              (tagbody
  42.           (loop                ;repeat forever ...
  43.         ;check for a breakpoint
  44.         (when (and (not (equal *fcn* '*all*))
  45.                (not (equal *fcn* (car form))))
  46.             (unless (and *fcn* (member (car form) *steplist*))
  47.  
  48.                 ;no breakpoint reached -- continue
  49.                 (setf (cdr *steptrace*) NIL)
  50.                 (when (car *steptrace*)
  51.                       (setf (cdr *steptrace*) T)
  52.                   (fcprt form)
  53.                   (terpri))
  54.                         (setf val (evalhook form
  55.                     #'eval-hook-function
  56.                     nil
  57.                     env))
  58.             (go next)))
  59.  
  60.         ;breakpoint reached -- fix things & get a command
  61.         (fcprt form)
  62.         (setf (cdr *steptrace*) T)
  63.         (setf *fcn* '*all*)    ;reset breakpoint specifier
  64.             (princ ":")        ;prompt user
  65.             (step-flush)        ;clear garbage from input line
  66.         (setf cmd (read-char))    ;get command from user
  67.  
  68.         ;process user's command
  69.                 (cond
  70.           ((char-equal cmd #\n)        ;step into function
  71.                    (setf val (evalhook    form
  72.                     #'eval-hook-function
  73.                     nil
  74.                     env))
  75.                    (go next))
  76.                   ((char-equal cmd #\s)        ;step over function
  77.                        (setf val (evalhook form nil nil env))
  78.                        (go next))
  79.                   ((char-equal cmd #\g)        ;go until breakpt. reached
  80.            (terpri)
  81.                    (setf *fcn* t)
  82.                    (setf val (evalhook form
  83.                 #'eval-hook-function
  84.                 nil
  85.                 env))
  86.            (go next))
  87.           ((char-equal cmd #\w)        ;backtrace
  88.            (step-baktrace))
  89.                   ((char-equal cmd #\h)        ;display help
  90.                     (step-help))
  91.           ((char-equal cmd #\p)        ;pretty-print form
  92.                (terpri)
  93.                (pprint form))
  94.                   ((char-equal cmd #\f)        ;set function breakpoint
  95.                    (setf *fcn* (read)))
  96.           ((char-equal cmd #\b)        ;set breakpoint
  97.            (step-set-breaks (read)))
  98.           ((char-equal cmd #\c)        ;clear a breakpoint
  99.            (step-clear-breaks (read)))
  100.           ((char-equal cmd #\t)        ;toggle trace mode
  101.            (setf (car *steptrace*)
  102.                 (not (car *steptrace*))))
  103.           ((char-equal cmd #\q)        ;quit stepper
  104.                   (setf *fcn* nil))
  105.           ((char-equal cmd #\x)        ;evaluate a form
  106.                    (step-do-form (read) env))
  107.           ((char-equal cmd #\*)        ;set new compress level
  108.            (step-set-compression (read)))
  109.           ((char-equal cmd #\e)        ;print environment
  110.            (step-print-env env))
  111.           (t (princ "Bad command.  Type h<cr> for help\n"))))
  112.  
  113.     next                    ;exit from loop
  114.           (setf *callist* (cdr *callist*))    ;remove fn. from call list
  115.           (when (cdr *steptrace*)
  116.               (step-spaces *hooklevel*)
  117.               (princ *hooklevel*)
  118.               (princ " <==< ")       ;print the result
  119.               (prin1 val)
  120.               (terpri))))
  121.  
  122.        ;not an interpreted function -- just trace thru.
  123.            (t (unless (not (symbolp form))
  124.         (when (car *steptrace*)
  125.                 (step-spaces *hooklevel*) ;if form is a symbol ...
  126.                     (princ "         ")
  127.                     (prin1 form)          ;... print the form ...
  128.                     (princ " = ")))
  129.               (setf val (evalhook form nil nil env)) ;eval it
  130.               (unless (not (symbolp form))
  131.         (when (car *steptrace*)
  132.                     (prin1 val)             ;... and value
  133.                     (terpri)))))
  134.      (setf *hooklevel* (1- *hooklevel*))     ;decrement level
  135.      val)                                    ;and return the value
  136.  
  137. ;compress a list
  138. (defun compress (l cf)        ;cf == compression factor
  139.   (cond ((null l) nil)
  140.     ((atom l) l)
  141.       ((eql cf 0) (if (atom l) l '**))
  142.       (T (cons (compress (car l) (1- cf)) (compress (cdr l) cf)))))
  143.  
  144. ;compress and print a form
  145. (defun fcprt (form)
  146.   (step-spaces *hooklevel*)
  147.   (princ *hooklevel*)
  148.   (princ " >==> ")
  149.   (prin1 (compress form *cf*))
  150.   (princ " "))
  151.  
  152. ;a non-recursive fn to print spaces (not as elegant, easier on the gc)
  153. (defun step-spaces (n) (dotimes (i n) (princ " ")))
  154.  
  155. ;and one to clear the input buffer
  156. (defun step-flush () (while (not (eql (read-char) newline))))
  157.  
  158. ;print help
  159. (defun step-help ()
  160.    (terpri)
  161.    (princ "Stepper Commands\n")
  162.    (princ "----------------\n")
  163.    (princ "          n - next form\n")
  164.    (princ "          s - step over form\n")
  165.    (princ " f FUNCTION - go until FUNCTION is called\n")
  166.    (princ " b FUNCTION - set breakpoint at FUNCTION\n")
  167.    (princ " b <list>   - set breakpoint at each function in list\n")
  168.    (princ " c FUNCTION - clear breakpoint at FUNCTION\n")
  169.    (princ " c <list>   - clear breakpoint at each function in list\n")
  170.    (princ " c *all*    - clear all breakpoints\n")
  171.    (princ "          g - go until a breakpoint is reached\n")
  172.    (princ "          w - where am I? -- backtrace\n")
  173.    (princ "          t - toggle trace on/off\n")
  174.    (princ "          q - quit stepper, continue execution\n")
  175.    (princ "          p - pretty-print current form (uncompressed)\n")
  176.    (princ "          e - print environment\n")
  177.    (princ "   x <expr> - execute expression in current environment\n")
  178.    (princ "       * nn - set list compression to nn\n")
  179.    (princ "          h - print this summary\n")
  180.    (princ "  All commands are terminated by <cr>\n")
  181.    (terpri))
  182.  
  183. ;evaluate a form in the given environment
  184. (defun step-do-form (f1 env)
  185.   (step-spaces *hooklevel*)
  186.   (princ *hooklevel*)
  187.   (princ " res: ")
  188.   (prin1 (evalhook f1 nil nil env))   ;print result
  189.   (princ " "))
  190.  
  191. ;set new compression factor
  192. (defun step-set-compression (cf)
  193.   (cond ((numberp cf)
  194.      (setf *cf* (truncate cf)))
  195.     (t (setf *cf* 2))))
  196.  
  197. ;print environment
  198. (defun step-print-env (env)
  199.   (step-spaces *hooklevel*)
  200.   (princ *hooklevel*)
  201.   (princ " env: ")
  202.   (prin1 env)
  203.   (terpri))
  204.  
  205. ;set breakpoints
  206. (defun step-set-breaks (l)
  207.   (cond ((null l) t)
  208.     ((symbolp l) (setf *steplist* (cons l *steplist*)))
  209.         ((listp l)
  210.        (step-set-breaks (car l))
  211.        (step-set-breaks (cdr l)))))
  212.  
  213. ;clear breakpoints
  214. (defun step-clear-breaks (l)
  215.   (cond ((null l) t)
  216.     ((eql l '*all*) (setf *steplist* nil))
  217.       ((symbolp l) (delete l *steplist*))
  218.       ((listp l)
  219.        (step-clear-breaks (car l))
  220.        (step-clear-breaks (cdr l)))))
  221.  
  222. ;print backtrace
  223. (defun step-baktrace (&aux l n)
  224.   (setf l *callist*)
  225.   (setf n *hooklevel*)
  226.   (while (>= n 0)
  227.     (step-spaces n)
  228.     (prin1 n) (princ " ")
  229.     (prin1 (car l))
  230.     (terpri)
  231.     (setf l (cdr l))
  232.     (setf n (1- n))))
  233.